home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / turtle.lisp < prev   
Text File  |  1993-07-17  |  25KB  |  698 lines
  1. ; -*- SYNTAX: ZETALISP; MODE: LISP; PACKAGE: BOXER; BASE: 10; FONTS: CPTFONT,CPTFONTB; -*-
  2.  
  3. #|
  4.             Copyright 1985 Massachusetts Institute of Technology
  5.  
  6.  Permission to use, copy, modify, distribute, and sell this software
  7.  and its documentation for any purpose is hereby granted without fee,
  8.  provided that the above copyright notice appear in all copies and that
  9.  both that copyright notice and this permission notice appear in
  10.  supporting documentation, and that the name of M.I.T. not be used in
  11.  advertising or publicity pertaining to distribution of the software
  12.  without specific, written prior permission.  M.I.T. makes no
  13.  representations about the suitability of this software for any
  14.  purpose.  It is provided "as is" without express or implied warranty.
  15.  
  16.  
  17.                                          +-Data--+
  18.                 This file is part of the | BOXER | system
  19.                                          +-------+
  20.  
  21.  
  22.   This file contains basic turtle methods.
  23.  
  24.  
  25. |#
  26.  
  27. (DEFVAR %LEARNING-SHAPE? NIL "This is t when doing a set-shape")
  28. (DEFVAR %MOUSE-USURPED NIL "Used in move-to to prevent changing boxes")
  29. (DEFVAR %NEW-SHAPE NIL "The new shape vectors are collected here when doing a set-shape") 
  30. (DEFVAR %TURTLE-STATE NIL "a place to save the turtle's position, pen, and heading.
  31. Used primarily when doing a set-shape")
  32.  
  33. ;;; Basic constructors, assessors, mutators for Turtles
  34. ;;; all update both the instance var and the box representation of it
  35. ;;; Note that several selectors have absolute versions (:absolute-x-position, for
  36. ;;; example).  These do the calculation to get the turtle's real position from
  37. ;;; its relative position, in the case when it is a subsprite
  38.  
  39. (DEFMETHOD (TURTLE :SET-ASSOC-GRAPHICS-BOX-INSTANCE-VAR) (NEW-BOX)
  40.   (SETQ ASSOC-GRAPHICS-BOX NEW-BOX)
  41.   (DOLIST (SUBS SUBSPRITES)
  42.     (TELL SUBS :SET-ASSOC-GRAPHICS-BOX-INSTANCE-VAR NEW-BOX)))
  43.  
  44. (DEFMETHOD (TURTLE :SET-ASSOC-GRAPHICS-BOX) (NEW-BOX)
  45.   (WHEN (NOT-NULL ASSOC-GRAPHICS-BOX) (TELL SELF :ERASE))
  46.   (TELL SELF :SET-ASSOC-GRAPHICS-BOX-INSTANCE-VAR NEW-BOX)
  47.   (WHEN (AND (NOT-NULL NEW-BOX)
  48.          (TELL SELF :ABSOLUTE-SHOWN-P))
  49.     (TELL SELF :DRAW)))
  50.  
  51.  
  52. (DEFMETHOD (TURTLE :X-POSITION) ()
  53.   (FIRST X-POSITION))
  54.  
  55. (DEFMETHOD (TURTLE :ABSOLUTE-X-POSITION) ()
  56.     (IF SUPERIOR-TURTLE
  57.     (LET ((SUP-HEADING (TELL SUPERIOR-TURTLE :ABSOLUTE-HEADING))
  58.           (SUP-XPOS (TELL SUPERIOR-TURTLE :ABSOLUTE-X-POSITION))
  59.           (ABS-SIZE (TELL SELF :ABSOLUTE-SIZE)))
  60.       (+ SUP-XPOS
  61.          (* (COSD SUP-HEADING) (CAR X-POSITION) ABS-SIZE)
  62.          (* (SIND SUP-HEADING) (CAR Y-POSITION) ABS-SIZE)))
  63.       (CAR X-POSITION)))
  64.  
  65. (DEFMETHOD (TURTLE :MAKE-ABSOLUTE) (XPOS YPOS)
  66.   (IF SUPERIOR-TURTLE 
  67.       (LET ((SUP-HEADING (TELL SUPERIOR-TURTLE :ABSOLUTE-HEADING))
  68.         (SUP-XPOS (TELL SUPERIOR-TURTLE :ABSOLUTE-X-POSITION))
  69.         (ABS-SIZE (TELL SELF :ABSOLUTE-SIZE))
  70.         (SUP-YPOS (TELL SUPERIOR-TURTLE :ABSOLUTE-Y-POSITION)))
  71.     (VALUES (+ SUP-XPOS
  72.            (* (COSD SUP-HEADING) XPOS ABS-SIZE)
  73.            (* (SIND SUP-HEADING) YPOS ABS-SIZE))
  74.         (+ SUP-YPOS
  75.            (* (- (SIND SUP-HEADING)) XPOS ABS-SIZE)
  76.            (* (COSD SUP-HEADING) YPOS ABS-SIZE))))
  77.       (VALUES XPOS YPOS)))
  78.  
  79. (DEFMETHOD (TURTLE :Y-POSITION) ()
  80.   (FIRST Y-POSITION))
  81.  
  82. (DEFMETHOD (TURTLE :ABSOLUTE-Y-POSITION) ()
  83.     (IF SUPERIOR-TURTLE
  84.     (LET ((SUP-HEADING (TELL SUPERIOR-TURTLE :ABSOLUTE-HEADING))
  85.           (SUP-YPOS (TELL SUPERIOR-TURTLE :ABSOLUTE-Y-POSITION))
  86.           (ABS-SIZE (TELL SELF :ABSOLUTE-SIZE)))
  87.       (+ SUP-YPOS
  88.          (* (- (SIND SUP-HEADING)) (CAR X-POSITION) ABS-SIZE)
  89.          (* (COSD SUP-HEADING) (CAR Y-POSITION) ABS-SIZE)))
  90.       (CAR Y-POSITION)))
  91.  
  92. (DEFMETHOD (TURTLE :ADD-XPOS-BOX) (BOX)
  93.   (SETQ X-POSITION (CONS (CAR X-POSITION) BOX)))
  94.  
  95. (DEFMETHOD (TURTLE :REMOVE-XPOS-BOX) ()
  96.   (SETQ X-POSITION (NCONS (CAR X-POSITION))))
  97.  
  98. (DEFMETHOD (TURTLE :ADD-YPOS-BOX) (BOX)
  99.   (SETQ Y-POSITION (CONS (CAR Y-POSITION) BOX)))
  100.  
  101. (DEFMETHOD (TURTLE :REMOVE-YPOS-BOX) ()
  102.   (SETQ Y-POSITION (NCONS (CAR Y-POSITION))))
  103.  
  104. (DEFMETHOD (TURTLE :SET-X-POSITION) (NEW-VALUE)
  105.   (LET ((BOX (CDR X-POSITION)))
  106.     (WHEN BOX
  107.       (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
  108.       (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-VALUE)))
  109.       (TELL BOX :MODIFIED))
  110.     (SETF (CAR X-POSITION) NEW-VALUE)))
  111.  
  112. (DEFMETHOD (TURTLE :SET-Y-POSITION) (NEW-VALUE)
  113.   (LET ((BOX (CDR Y-POSITION)))
  114.     (WHEN BOX
  115.       (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
  116.       (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-VALUE)))
  117.       (TELL BOX :MODIFIED))
  118.     (SETF (CAR Y-POSITION) NEW-VALUE)))
  119.  
  120. (DEFMETHOD (TURTLE :SET-XY) (NEW-X NEW-Y)
  121.   (LET ((BOX (CDR X-POSITION)))
  122.     (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
  123.     (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-X)))
  124.     (TELL BOX :MODIFIED)
  125.     (SETF (CAR X-POSITION) NEW-X))
  126.   (LET ((BOX (CDR Y-POSITION)))
  127.     (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
  128.     (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-Y)))
  129.     (TELL BOX :MODIFIED)
  130.     (SETF (CAR Y-POSITION) NEW-Y)))
  131.  
  132.  
  133. (DEFMETHOD (TURTLE :HEADING) ()
  134.   (FIRST HEADING))
  135.  
  136. (DEFMETHOD (TURTLE :ABSOLUTE-HEADING) ()
  137.   (IF SUPERIOR-TURTLE
  138.       (+ (CAR HEADING) (TELL SUPERIOR-TURTLE :ABSOLUTE-HEADING))
  139.       (CAR HEADING)))
  140.  
  141. (DEFMETHOD (TURTLE :SET-HEADING-INSTANCE-VAR) (NEW-VALUE)
  142.   (LET ((BOX (CDR HEADING)))
  143.     (WHEN BOX
  144.       (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
  145.       (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-VALUE)))
  146.       (TELL BOX :MODIFIED))
  147.     (SETF (CAR HEADING) NEW-VALUE)))
  148.  
  149. (DEFMETHOD (TURTLE :ADD-HEADING-BOX) (BOX)
  150.   (SETQ HEADING (CONS (CAR HEADING) BOX)))
  151.  
  152. (DEFMETHOD (TURTLE :REMOVE-HEADING-BOX) ()
  153.   (SETQ HEADING (NCONS (CAR  HEADING))))
  154.  
  155. (DEFMETHOD (TURTLE :PEN) ()
  156.   (CAR PEN))
  157.  
  158. (DEFUN GET-ALU-FROM-PEN (PEN-MODE)
  159.   (SELECTQ PEN-MODE
  160.     ((DOWN :DOWN BU:DOWN) TV:ALU-IOR)
  161.     ((UP :UP BU:UP) NIL)
  162.     ((ERASE :ERASE BU:ERASE) TV:ALU-ANDCA)
  163.     ((XOR :XOR BU:XOR) TV:ALU-XOR)))
  164.  
  165. (DEFMETHOD (TURTLE :SET-PEN) (NEW-VALUE)
  166.   (IF %LEARNING-SHAPE? ;;; When learning shape add pen to vector list
  167.      (SETQ %NEW-SHAPE (APPEND %NEW-SHAPE (NCONS NEW-VALUE)))  
  168.      (LET ((BOX (CDR PEN)))
  169.        (WHEN BOX
  170.          (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
  171.          (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-VALUE)))
  172.          (TELL BOX :MODIFIED))
  173.        (SETF (CAR PEN) NEW-VALUE))))
  174.  
  175.  
  176. (DEFMETHOD (TURTLE :ADD-PEN-BOX) (BOX)
  177.   (SETQ PEN (CONS (CAR PEN) BOX)))
  178.  
  179. (DEFMETHOD (TURTLE :REMOVE-PEN-BOX) ()
  180.   (SETQ PEN (NCONS :DOWN)))
  181.  
  182. (DEFMETHOD (TURTLE :SET-HOME) (NEW-X NEW-Y)
  183.   (LET ((BOX (CDR HOME)))
  184.     (WHEN BOX
  185.       (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
  186.       (TELL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-X NEW-Y)))
  187.       (TELL BOX :MODIFIED))
  188.     (SETF (CAR HOME) (LIST NEW-X NEW-Y))))
  189.  
  190. (DEFMETHOD (TURTLE :ADD-HOME-BOX) (BOX)
  191.   (SETQ HOME (CONS (CAR HOME) BOX)))
  192.  
  193. (DEFMETHOD (TURTLE :REMOVE-HOME-BOX) ()
  194.   (SETQ HOME (NCONS '(0 0))))
  195.  
  196. (DEFMETHOD (TURTLE :HOME-X) ()
  197.   (CAAR HOME))
  198.  
  199. (DEFMETHOD (TURTLE :HOME-Y) ()
  200.   (CADAR HOME))
  201.  
  202. (DEFMETHOD (TURTLE :SET-SHOWN-P) (NEW-VALUE)
  203.   (LET ((BOX (CDR SHOWN-P))
  204.     (TOP-GUY (TELL SELF :TOP-SPRITE)))
  205.     (TELL TOP-GUY :ERASE)
  206.     (MULTIPLE-VALUE-BIND (WORD VALUE)
  207.     (SELECTQ NEW-VALUE
  208.       ((T BU:ALL BU:TRUE) (VALUES 'TRUE T))
  209.       ((NIL BU:NONE BU:FALSE) (VALUES 'FALSE NIL))
  210.       ((:SUBSPRITES BU:SUBSPRITES) (VALUES 'SUBSPRITES :SUBSPRITES))
  211.       ((:NO-SUBSPRITES BU:NO-SUBSPRITES) (VALUES 'NO-SUBSPRITES ':NO-SUBSPRITES)))
  212.       (WHEN BOX
  213.     (TELL BOX :SET-FIRST-INFERIOR-ROW NIL)
  214.     (TELL BOX :APPEND-ROW
  215.           (MAKE-ROW (LIST WORD)))
  216.     (TELL BOX :MODIFIED))
  217.       (SETQ SHOWN-P (CONS VALUE (CDR SHOWN-P)))
  218.       (WHEN (TELL TOP-GUY :SHOWN-P)
  219.     (TELL TOP-GUY :DRAW)))))
  220.  
  221. (DEFMETHOD (TURTLE :SHOWN-P-SYMBOL) ()
  222.   (SELECTQ (CAR SHOWN-P)
  223.     ((NIL) 'FALSE)
  224.     ((:SUBSPRITES) 'SUBSPRITES)
  225.     ((:NO-SUBSPRITES) 'NO-SUBSPRITES)
  226.     (T 'TRUE)))
  227.  
  228. (DEFMETHOD (TURTLE :TOP-SPRITE) ()
  229.   (IF SUPERIOR-TURTLE
  230.       (TELL SUPERIOR-TURTLE :TOP-SPRITE)
  231.       SELF))
  232.  
  233. (DEFMETHOD (TURTLE :SHOWN-P) ()
  234.   (NOT (NOT (CAR SHOWN-P))))
  235.  
  236. (DEFMETHOD (TURTLE :SUBSPRITES-SHOWN-P) ()
  237.   (IF SUPERIOR-TURTLE
  238.       (AND (TELL SUPERIOR-TURTLE :SUBSPRITES-SHOWN-P)
  239.        (MEMQ (CAR SHOWN-P) '(T :SUBSPRITES)))
  240.       (MEMQ (CAR SHOWN-P) '(T :SUBSPRITES))))
  241.            
  242.  
  243. (DEFMETHOD (TURTLE :ABSOLUTE-SHOWN-P) ()
  244.   (LET ((SH (CAR SHOWN-P)))
  245.     (IF SUPERIOR-TURTLE
  246.     (IF (NULL SH)
  247.         NIL
  248.         (TELL SUPERIOR-TURTLE :SUBSPRITES-SHOWN-P))
  249.     (NOT (NOT SH)))))
  250.  
  251. (DEFMETHOD (TURTLE :ADD-SHOWN-P-BOX) (BOX)
  252.   (SETQ SHOWN-P (CONS (CAR SHOWN-P) BOX)))
  253.  
  254. (DEFMETHOD (TURTLE :REMOVE-SHOWN-P-BOX) ()
  255.   (SETQ SHOWN-P (NCONS (CAR SHOWN-P)))
  256.   (TELL SELF :SET-SHOWN-P T))
  257.  
  258. (DEFMETHOD (TURTLE :SET-SIZE) (NEW-SIZE)
  259.   (IF (<= NEW-SIZE 0)
  260.       (FERROR "Argument to Set-size, ~d , was less than or equal to zero" NEW-SIZE)
  261.       (TELL SELF :ERASE)
  262.       (LET ((BOX (CDR SIZE)))
  263.     (TELL-CHECK-NIL BOX :SET-FIRST-INFERIOR-ROW NIL)
  264.     (TELL-CHECK-NIL BOX :APPEND-ROW (MAKE-ROW (LIST NEW-SIZE)))
  265.     (TELL-CHECK-NIL BOX :MODIFIED)
  266.     (SETF (CAR SIZE) NEW-SIZE))
  267.       (TELL SELF :DRAW)))
  268.  
  269. (DEFMETHOD (TURTLE :ABSOLUTE-SIZE) ()
  270.   (IF SUPERIOR-TURTLE
  271.       (* (CAR SIZE) (TELL SUPERIOR-TURTLE :ABSOLUTE-SIZE))
  272.       (CAR SIZE)))
  273.  
  274. (DEFMETHOD (TURTLE :SIZE) ()
  275.   (CAR SIZE))
  276.  
  277. (DEFMETHOD (TURTLE :ADD-SIZE-BOX) (BOX)
  278.   (SETQ SIZE (CONS (CAR SIZE) BOX)))
  279.   
  280.  
  281. (DEFMETHOD (TURTLE :REMOVE-SIZE-BOX) ()
  282.   (SETQ SIZE (NCONS (CAR SIZE)))
  283.   (TELL SELF :SET-SIZE 1))
  284.  
  285. (DEFMETHOD (TURTLE :SHAPE) ()
  286.   (CAR SHAPE))
  287.  
  288. (DEFMETHOD (TURTLE :ADD-SHAPE-BOX) (BOX)
  289.   (SETQ SHAPE (CONS (CAR SHAPE) BOX)))
  290.  
  291. (DEFMETHOD (TURTLE :REMOVE-SHAPE-BOX) ()
  292.   (TELL SELF :ERASE)
  293.   (SETQ SHAPE (LIST *TURTLE-SHAPE*))
  294.   (TELL SELF :DRAW))
  295.  
  296. (DEFMETHOD (TURTLE :ADD-SUBTURTLE) (SUBTURTLE)
  297.   (TELL SUBTURTLE :SET-SUPERIOR-TURTLE SELF)
  298.   (TELL SUBTURTLE :SET-ASSOC-GRAPHICS-BOX ASSOC-GRAPHICS-BOX)
  299.   (SETQ SUBSPRITES (CONS SUBTURTLE SUBSPRITES)))
  300.  
  301. (DEFMETHOD (TURTLE :REMOVE-SUBTURTLE) (SUBTURTLE)
  302.   (TELL SUBTURTLE :SET-ASSOC-GRAPHICS-BOX NIL)
  303.   (TELL SUBTURTLE :SET-SUPERIOR-TURTLE NIL)
  304.   (SETQ SUBSPRITES (DELQ SUBTURTLE SUBSPRITES)))
  305.  
  306. ; The higher level stuff.
  307.  
  308. ;;; ALL TURTLE functions are assumed to be called in an environment where the various
  309. ;;; turtle state variables as well as GRAPHICS vars (like BIT-ARRAY) are BOUND.
  310. ;;; This is what the MACRO WITH-TURTLE-VARS-BOUND is used for.
  311. ;;; The three main entry points into turtle graphics are the messages...
  312. ;;; :MOVE-TO
  313. ;;; :TURN-TO  and
  314. ;;; :DRAW
  315. ;;; These three methods have WHOPPERS with the proper macro wrapped around them...
  316. ;;; All other turtle functions that do things to the screen should be built out of these or
  317. ;;; at least use the macro so that things get drawn in the right place
  318.  
  319.  
  320.  
  321. ;;;ED -- If you look at the stack during the execution of any sprite command,
  322. ;;;macros are nested many times.  For example the draw whopper gets called for 
  323. ;;;drawing each subsprite of a sprite.  If that sprite moved, the move-to whopper would
  324. ;;;be called too.   Someone should probably clean this up so that these whoppers get
  325. ;;; called only once for each turtle command.
  326.  
  327. (DEFWHOPPER (TURTLE :MOVE-TO) (&REST ARGS)
  328.   (WITH-GRAPHICS-VARS-BOUND ASSOC-GRAPHICS-BOX
  329.     (LEXPR-CONTINUE-WHOPPER ARGS)))
  330.  
  331. (DEFWHOPPER (TURTLE :TURN-TO) (NEW-HEADING)
  332.   (WITH-GRAPHICS-VARS-BOUND ASSOC-GRAPHICS-BOX
  333.     (CONTINUE-WHOPPER NEW-HEADING)))
  334.  
  335. (DEFWHOPPER (TURTLE :DRAW) (&REST ARGS)
  336.  (WITH-GRAPHICS-VARS-BOUND ASSOC-GRAPHICS-BOX
  337.     (LEXPR-CONTINUE-WHOPPER ARGS)))
  338.  
  339. ;;; Drawing the turtle...
  340.  
  341. (DEFMETHOD (TURTLE :DRAW) (&OPTIONAL (ALU TV:ALU-XOR))
  342.   (UNLESS (EQ (CAR SHOWN-P) :SUBSPRITES)
  343.     (DRAW-VECTOR-LIST
  344.       (CAR SHAPE)
  345.       (TELL SELF :ABSOLUTE-SIZE)
  346.       (ARRAY-COORDINATE-X (TELL SELF :ABSOLUTE-X-POSITION))
  347.       (ARRAY-COORDINATE-Y (TELL SELF :ABSOLUTE-Y-POSITION))
  348.       (TELL SELF :ABSOLUTE-HEADING)
  349.       ALU))
  350.   (UNLESS (EQ (CAR SHOWN-P) :NO-SUBSPRITES)
  351.     (DOLIST (SUBS SUBSPRITES)
  352.     (TELL SUBS :DRAW)))
  353.   (TELL ASSOC-GRAPHICS-BOX :MODIFIED))
  354.  
  355. (DEFMETHOD (TURTLE :ERASE) ()
  356.   (WHEN (TELL SELF :ABSOLUTE-SHOWN-P) (TELL SELF :DRAW)))
  357.  
  358. (DEFMETHOD (TURTLE :SHOW-TURTLE) ()
  359.   (TELL SELF :SET-SHOWN-P T))
  360.  
  361. (DEFMETHOD (TURTLE :HIDE-TURTLE) ()
  362.   (TELL SELF :SET-SHOWN-P NIL))
  363.  
  364. ;;; Moving around
  365.  
  366. (DEFMETHOD (TURTLE :MOVE-TO) (X-DEST Y-DEST)
  367.   (IF (NOT (AND (NUMBERP X-DEST) (NUMBERP Y-DEST)))
  368.       (FERROR "one of the args, ~s or ~s, was not a number" X-DEST Y-DEST)
  369.       (COND (%LEARNING-SHAPE?          ;;; don't draw while learning shape.
  370.          (SETQ %NEW-SHAPE (APPEND %NEW-SHAPE
  371.                       (LIST (- X-DEST (CAR X-POSITION))
  372.                         (- (CAR Y-POSITION) Y-DEST))))
  373.          ;;; While in learning-shape, don't update any boxes
  374.          (SETF (CAR X-POSITION) X-DEST)
  375.          (SETF (CAR Y-POSITION) Y-DEST))
  376. ; Have to make fence mode work some other time
  377. ;        ((and (eq %draw-mode ':fence)
  378. ;          (not (point-in-array? array-x-dest array-y-dest)))
  379. ;         (ferror "you hit the fence"))
  380.         (T
  381.          (MULTIPLE-VALUE-BIND (ARRAY-X-DEST ARRAY-Y-DEST)
  382.          (TELL SELF :MAKE-ABSOLUTE X-DEST Y-DEST)
  383.            (SETQ ARRAY-X-DEST (FIX-ARRAY-COORDINATE-X ARRAY-X-DEST)
  384.              ARRAY-Y-DEST (FIX-ARRAY-COORDINATE-Y ARRAY-Y-DEST))
  385.            (LET ((ARRAY-X (FIX-ARRAY-COORDINATE-X (TELL SELF :ABSOLUTE-X-POSITION)))
  386.              (ARRAY-Y (FIX-ARRAY-COORDINATE-Y (TELL SELF :ABSOLUTE-Y-POSITION)))
  387.              (PEN-ALU (GET-ALU-FROM-PEN (CAR PEN))))
  388.          (WITHOUT-INTERRUPTS
  389.            (WHEN (AND (NULL SUPERIOR-TURTLE) (EQ %DRAW-MODE ':WRAP))
  390.              (SETQ X-DEST (WRAP-X-COORDINATE X-DEST)
  391.                Y-DEST (WRAP-Y-COORDINATE Y-DEST)))
  392.            (TELL SELF :ERASE)
  393.            (IF %MOUSE-USURPED
  394.                ;;; don't update boxes during follow-mouse
  395.                (PROGN (SETF (CAR X-POSITION) X-DEST)
  396.                   (SETF (CAR Y-POSITION) Y-DEST))
  397.                (TELL SELF :SET-XY X-DEST Y-DEST))
  398.            (WHEN PEN-ALU
  399.              (CK-MODE-DRAW-LINE ARRAY-X      ARRAY-Y
  400.                     ARRAY-X-DEST ARRAY-Y-DEST
  401.                     PEN-ALU)))            
  402.          (WHEN (TELL SELF :ABSOLUTE-SHOWN-P) (TELL SELF :DRAW))
  403.          (TELL %GRAPHICS-BOX :MODIFIED)))))))
  404.        
  405.  
  406. (DEFMETHOD (TURTLE :FORWARD) (DISTANCE)
  407.   (LET* ((HEAD (CAR HEADING))
  408.      (CHANGE-X (* DISTANCE (SIND HEAD)))
  409.      (CHANGE-Y (* DISTANCE (COSD HEAD))))
  410.     (TELL SELF :MOVE-TO
  411.       (+ CHANGE-X (CAR X-POSITION)) (+ CHANGE-Y (CAR Y-POSITION)))))
  412.  
  413. (DEFMETHOD (TURTLE :GO-HOME) ()
  414.   (TELL SELF :MOVE-TO (CAAR HOME) (CADAR HOME))
  415.   (TELL SELF :TURN-TO 0))
  416.  
  417. ;;; Turning around
  418. (DEFMETHOD (TURTLE :TURN-TO) (NEW-HEADING)
  419.   (COND ((NUMBERP NEW-HEADING)
  420.      (IF %LEARNING-SHAPE?
  421.          (TELL SELF :SET-HEADING-INSTANCE-VAR (FLOAT-MODULO NEW-HEADING 360))
  422.          (WITHOUT-INTERRUPTS
  423.            (TELL SELF :ERASE)
  424.            (TELL SELF :SET-HEADING-INSTANCE-VAR (FLOAT-MODULO NEW-HEADING 360))
  425.            (WHEN (TELL SELF :ABSOLUTE-SHOWN-P) (TELL SELF :DRAW))
  426.            (TELL %GRAPHICS-BOX :MODIFIED))))
  427.     (T (FERROR "the argument, ~s, was not a number" NEW-HEADING))))
  428.  
  429. (DEFMETHOD (TURTLE :RIGHT) (DEGREES)
  430.   (TELL SELF :TURN-TO (+ (CAR HEADING) DEGREES)))
  431.  
  432. (DEFMETHOD (TURTLE :TURN-TO-WITHOUT-DRAW) (NEW-HEADING)
  433.   (COND ((NUMBERP NEW-HEADING)
  434.      (TELL SELF :SET-HEADING-INSTANCE-VAR (FLOAT-MODULO NEW-HEADING 360)))
  435.     (T (FERROR "the argument, ~s, was not a number" NEW-HEADING))))
  436.  
  437. (DEFMETHOD (TURTLE :ROTATE) (DEGREES)
  438.   (TELL SELF :ERASE)
  439.   (DOLIST (SUBS SUBSPRITES)
  440.     (TELL SUBS :TURN-TO-WITHOUT-DRAW (- (TELL SUBS :HEADING) DEGREES)))
  441.   (TELL SELF :TURN-TO-WITHOUT-DRAW (+ (CAR HEADING) DEGREES))
  442.   (WHEN (TELL SELF :ABSOLUTE-SHOWN-P) (TELL SELF :DRAW)))
  443.  
  444. ;;; stupidly returns degrees needed to turn right instead of heading to turn towards
  445. ;(DEFMETHOD (TURTLE :TOWARDS) (X Y)
  446. ;  (COND ((AND (< (ABS (- X (CAR X-POSITION))) .0001) (> Y (CAR Y-POSITION)))
  447. ;     (- 360. (CAR HEADING)))
  448. ;    ((< (ABS (- X (CAR X-POSITION))) .0001)
  449. ;     (FLOAT-MODULO (+ (- 360 (CAR HEADING)) 180.) 360.))
  450. ;    (T (FLOAT-MODULO (+ (- 360 (CAR HEADING))
  451. ;                (// (* 180. (ATAN (- X (CAR X-POSITION))
  452. ;                          (- Y (CAR Y-POSITION)))) )) 360.))))
  453. (DEFMETHOD (TURTLE :TOWARDS) (X Y)
  454.   (COND ((AND (< (ABS (- X (CAR X-POSITION))) .0001) (> Y (CAR Y-POSITION)))
  455.      0)
  456.     ((< (ABS (- X (CAR X-POSITION))) .0001)
  457.      180.)
  458.     (T (FLOAT-MODULO (// (* 180. (ATAN (- X (CAR X-POSITION))
  459.                        (- Y (CAR Y-POSITION)))) ) 360.))))
  460.  
  461. (DEFMETHOD (TURTLE :SET-HEADING) (NEW-HEADING)
  462.   (TELL SELF :TURN-TO NEW-HEADING))
  463.  
  464. ;;; changing shape
  465.  
  466. (DEFMETHOD (TURTLE :SAVE-STATE-AND-RESET) ()
  467.   (SETQ %TURTLE-STATE
  468.     (LIST (CAR X-POSITION) (CAR Y-POSITION) (CAR HEADING)))
  469.   (TELL SELF :SET-X-POSITION 0)
  470.   (TELL SELF :SET-Y-POSITION 0)
  471.   (TELL SELF :SET-HEADING 0))
  472.  
  473. (DEFMETHOD (TURTLE :RESTORE-STATE) ()
  474.   (TELL SELF :SET-X-POSITION (FIRST %TURTLE-STATE))
  475.   (TELL SELF :SET-Y-POSITION (SECOND %TURTLE-STATE))
  476.   (TELL SELF :SET-HEADING (THIRD %TURTLE-STATE)))
  477.  
  478. (DEFMETHOD (TURTLE :SET-SHAPE-FROM-BOX) (BOX)
  479.   (LET ((%LEARNING-SHAPE? T) (%NEW-SHAPE NIL))
  480.     (TELL SELF :SAVE-STATE-AND-RESET)
  481.     (if (send box :superior? sprite-box)
  482.     (BOXER-TELLING BOX BOX)
  483.     (BOXER-TELLING BOX SPRITE-BOX))
  484.     (TELL SELF :SET-PEN :UP)
  485.     (TELL SELF :MOVE-TO 0 0)
  486.     (TELL SELF :RESTORE-STATE)
  487.     (TELL SELF :ERASE)
  488.     (SETQ SHAPE (NCONS %NEW-SHAPE))
  489. ;    (tell-check-nil (cdr shape) :set-contents-from-stream
  490. ;            (make-box-stream box))
  491. ;    (tell-check-nil (cdr shape) :modified)
  492.     (when (tell self :shown-p) (TELL SELF :DRAW))
  493.     ))
  494.  
  495. ;;; Stuff for mouse-sensitivity
  496.  
  497. (DEFMETHOD (TURTLE :ENCLOSING-RECTANGLE) ()
  498.   (LET* ((XPOS (TELL SELF :ABSOLUTE-X-POSITION))
  499.      (YPOS (TELL SELF :ABSOLUTE-Y-POSITION))
  500.      (ABS-HEAD (TELL SELF :ABSOLUTE-HEADING))
  501.      (ABS-SIZE (TELL SELF :ABSOLUTE-SIZE))
  502.      (LEFT XPOS)
  503.      (RIGHT XPOS)
  504.      (TOP YPOS)
  505.      (BOTTOM YPOS))
  506.     (UNLESS (EQ (CAR SHOWN-P) :SUBSPRITES)
  507.       (MULTIPLE-VALUE (LEFT TOP RIGHT BOTTOM)
  508.     (CALC-RECTANGLE XPOS YPOS XPOS YPOS
  509.             (CAR SHAPE) XPOS YPOS
  510.             (* ABS-SIZE (COSD ABS-HEAD))
  511.             (* ABS-SIZE (SIND ABS-HEAD)))))
  512.     (UNLESS (EQ (CAR SHOWN-P) :NO-SUBSPRITES)
  513.       (DOLIST (SUBS SUBSPRITES)
  514.     (WHEN (TELL SUBS :ABSOLUTE-SHOWN-P)
  515.       (MULTIPLE-VALUE-BIND (SUB-LEFT SUB-TOP SUB-RIGHT SUB-BOTTOM)
  516.           (TELL SUBS :ENCLOSING-RECTANGLE)
  517.         (SETQ LEFT (MIN LEFT SUB-LEFT)
  518.           TOP (MAX TOP SUB-TOP)
  519.           RIGHT (MAX RIGHT SUB-RIGHT)
  520.           BOTTOM (MIN BOTTOM SUB-BOTTOM))))))
  521.     (VALUES LEFT TOP RIGHT BOTTOM)))
  522.  
  523. (DEFUN CALC-RECTANGLE (LEFT TOP RIGHT BOTTOM SHAPE X-POS Y-POS COS-HEAD SIN-HEAD)
  524.   (COND ((NULL SHAPE) (VALUES LEFT TOP RIGHT BOTTOM))
  525.     ((STRINGP (FIRST SHAPE))
  526.      (LET ((STRING-RIGHT 0) (STRING-BOTTOM 0))
  527.        (DO* ((STRING (SUBSTRING (FIRST SHAPE) 0 (OR(STRING-SEARCH-CHAR #\CR (FIRST SHAPE))
  528.                                (STRING-LENGTH (FIRST SHAPE))))
  529.             (SUBSTRING RSTRING 0 (OR (STRING-SEARCH-CHAR #\CR RSTRING)
  530.                         (STRING-LENGTH RSTRING))))
  531.          (RSTRING (SUBSTRING (FIRST SHAPE)
  532.                      (OR (AND (STRING-SEARCH-CHAR #\CR (FIRST SHAPE))
  533.                           (1+ (STRING-SEARCH-CHAR #\CR (FIRST SHAPE))))
  534.                      (STRING-LENGTH (FIRST SHAPE)))
  535.                      (STRING-LENGTH (FIRST SHAPE)))
  536.               (SUBSTRING RSTRING
  537.                      (OR (AND (STRING-SEARCH-CHAR #\CR RSTRING)
  538.                           (1+ (STRING-SEARCH-CHAR #\CR RSTRING)))
  539.                      (STRING-LENGTH RSTRING))
  540.                      (STRING-LENGTH RSTRING))))
  541.            ((STRING-EQUAL STRING ""))
  542.          (SETQ STRING-RIGHT
  543.            (MAX STRING-RIGHT (* *FONT-WIDTH*
  544.                     (STRING-LENGTH STRING)))
  545.            STRING-BOTTOM (- STRING-BOTTOM *FONT-HEIGHT* 2)))
  546.        (CALC-RECTANGLE LEFT TOP
  547.                (MAX RIGHT (+ X-POS 3. STRING-RIGHT))
  548.                (MIN BOTTOM (+ Y-POS 1. STRING-BOTTOM))
  549.                (CDR SHAPE) X-POS Y-POS COS-HEAD SIN-HEAD)))
  550.     ((NUMBERP (FIRST SHAPE))
  551.      (LET ((NEW-X (+ X-POS
  552.              (* (FIRST SHAPE) COS-HEAD)
  553.              (* (SECOND SHAPE) (- SIN-HEAD))))
  554.            (NEW-Y (+ Y-POS
  555.              (* (FIRST SHAPE) (- SIN-HEAD))
  556.              (* (SECOND SHAPE) (- COS-HEAD)))))
  557.        (CALC-RECTANGLE (MIN LEFT NEW-X) (MAX TOP NEW-Y)
  558.                (MAX RIGHT NEW-X) (MIN BOTTOM NEW-Y)
  559.                (CDDR SHAPE) NEW-X NEW-Y COS-HEAD SIN-HEAD)))
  560.     (T (CALC-RECTANGLE LEFT TOP RIGHT BOTTOM (CDR SHAPE)
  561.                X-POS Y-POS COS-HEAD SIN-HEAD))))
  562.  
  563. (DEFMETHOD (TURTLE :TOUCHING?) (OTHER-TURTLE)
  564.   (MULTIPLE-VALUE-BIND (LEFT1 TOP1 RIGHT1 BOTTOM1)
  565.       (TELL SELF :ENCLOSING-RECTANGLE)
  566.     (MULTIPLE-VALUE-BIND (LEFT2 TOP2 RIGHT2 BOTTOM2)
  567.     (TELL OTHER-TURTLE :ENCLOSING-RECTANGLE)
  568.       ;;; Check an edge at a time
  569.       (OR (AND (INCLUSIVE-BETWEEN? LEFT1 LEFT2 RIGHT2)
  570.            (OR (AND (>= TOP1 TOP2) (<= BOTTOM1 TOP2))
  571.            (AND (>= TOP1 BOTTOM2) (<= BOTTOM1 BOTTOM2))))
  572.       (AND (INCLUSIVE-BETWEEN? RIGHT1 LEFT2 RIGHT2)
  573.            (OR (AND (>= TOP1 TOP2) (<= BOTTOM1 TOP2))
  574.            (AND (>= TOP1 BOTTOM2) (<= BOTTOM1 BOTTOM2))))
  575.       (AND (INCLUSIVE-BETWEEN? TOP1 TOP2 BOTTOM2)
  576.            (OR (AND (>= RIGHT1 RIGHT2) (<= LEFT1 RIGHT2))
  577.            (AND (>= RIGHT1 LEFT2) (<= LEFT1 LEFT2))))
  578.       (AND (INCLUSIVE-BETWEEN? BOTTOM1 TOP2 BOTTOM2)
  579.            (OR (AND (>= RIGHT1 RIGHT2) (<= LEFT1 RIGHT2))
  580.            (AND (>= RIGHT1 LEFT2) (<= LEFT1 LEFT2))))
  581.       ;; Finally check a single point in each
  582.       (AND (INCLUSIVE-BETWEEN? LEFT2 LEFT1 RIGHT1)
  583.            (INCLUSIVE-BETWEEN? TOP2 TOP1 BOTTOM1))
  584.       (AND (INCLUSIVE-BETWEEN? LEFT1 LEFT2 RIGHT2)
  585.            (INCLUSIVE-BETWEEN? TOP1 TOP2 BOTTOM2))))))
  586.  
  587. (DEFMETHOD (TURTLE :SPRITE-UNDER) ()
  588.   (LET ((OBJECTS (TELL ASSOC-GRAPHICS-BOX :OBJECT-LIST)))
  589.     (SETQ OBJECTS (DELQ (TELL SELF :TOP-SPRITE) (COPYLIST OBJECTS)))
  590.     (FIND-SPRITE-UNDER-POINT (TELL SELF :ABSOLUTE-X-POSITION)
  591.                  (TELL SELF :ABSOLUTE-Y-POSITION)
  592.                  OBJECTS)))
  593.  
  594. (DEFMETHOD (TURTLE :ALL-SPRITES-IN-CONTACT) ()
  595.   (LET ((OBJECTS (TELL ASSOC-GRAPHICS-BOX :OBJECT-LIST))
  596.     TURTLES)
  597.     (SETQ OBJECTS (DELQ (TELL SELF :TOP-SPRITE) (COPYLIST OBJECTS)))
  598.     (DOLIST (OBJECT OBJECTS)
  599.       (WHEN (TELL SELF :TOUCHING? OBJECT)
  600.       (SETQ TURTLES (CONS OBJECT TURTLES))))
  601.     TURTLES))
  602.  
  603. (DEFUN CALC-NAME-POSITION-X (LENGTH LEFT RIGHT)
  604.   (SETQ LEFT (ARRAY-COORDINATE-X LEFT)
  605.     RIGHT (ARRAY-COORDINATE-X RIGHT))
  606.   (IF (> (+ RIGHT LENGTH) %DRAWING-WIDTH)
  607.       (FIXR (- LEFT LENGTH 3.))
  608.       (FIXR (+ RIGHT 5.))))
  609.  
  610. (DEFUN CALC-NAME-POSITION-Y (HEIGHT TOP BOTTOM)
  611.   (LET ((CENTER (+ (ARRAY-COORDINATE-Y TOP)
  612.            (// (- TOP BOTTOM) 2))))
  613.     (FIXR (MIN (MAX CENTER 0)
  614.      (- %DRAWING-HEIGHT HEIGHT 1.)))))
  615.  
  616. ;;; Drawing the turtle's name
  617.  
  618. (DEFMETHOD (TURTLE :FLASH-NAME) ()
  619.   (WITH-GRAPHICS-VARS-BOUND ASSOC-GRAPHICS-BOX
  620.     (LET* ((PRINT-NAME (TELL SPRITE-BOX :NAME))
  621.        (NAME-LENGTH (* *FONT-WIDTH* (STRING-LENGTH PRINT-NAME))))
  622.       (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
  623.       (TELL SELF :ENCLOSING-RECTANGLE)
  624.     (LET ((X-POS (CALC-NAME-POSITION-X NAME-LENGTH LEFT RIGHT))
  625.           (Y-POS (CALC-NAME-POSITION-Y *FONT-HEIGHT* TOP BOTTOM)))
  626.       (DRAW-STRING-TO-GBOX PRINT-NAME X-POS Y-POS)
  627.       (PROCESS-SLEEP 120 "Pausing to flash name")
  628.       (DRAW-STRING-TO-GBOX PRINT-NAME X-POS Y-POS))))))
  629.  
  630. (DEFUN PENUP? (PEN-MODE)
  631.   (MEMQ PEN-MODE '(UP :UP BU:UP)))
  632.  
  633. (DEFMETHOD (TURTLE :TYPE-BOX) (BOX)
  634.   (IF %LEARNING-SHAPE?
  635.       (SETQ %NEW-SHAPE (APPEND %NEW-SHAPE (NCONS (TEXT-STRING BOX))))
  636.       (UNLESS (PENUP? (CAR PEN))
  637.     (WITH-GRAPHICS-VARS-BOUND ASSOC-GRAPHICS-BOX
  638.       (LET ((XPOS (+ 3. (FIX-ARRAY-COORDINATE-X (CAR X-POSITION))))
  639.         (YPOS (1+ (FIX-ARRAY-COORDINATE-Y (CAR Y-POSITION)))))
  640.         (DRAW-STRING-TO-GBOX (TEXT-STRING BOX) XPOS YPOS (GET-ALU-FROM-PEN (CAR PEN))))))))
  641.  
  642. ;;; Following the mouse (Drawing with the mouse)
  643.  
  644.  
  645. (DEFMETHOD (TURTLE :USURP-MOUSE) (&AUX OLD-X OLD-Y)
  646.   (IF (GRAPHICS-BOX? ASSOC-GRAPHICS-BOX)
  647.       (UNWIND-PROTECT
  648.     (LET ((%MOUSE-USURPED T))
  649.       (TV:WITH-MOUSE-USURPED
  650.         (TAGBODY
  651.           (SETQ OLD-X TV:MOUSE-X OLD-Y TV:MOUSE-Y)
  652.           (SETQ TV:WHO-LINE-MOUSE-GRABBED-DOCUMENTATION "Sprite grabbed the mouse")
  653.           (TELL *POINT-BLINKER* :SET-VISIBILITY NIL)
  654.           (TELL TV:MOUSE-BLINKER :SET-VISIBILITY NIL)          
  655.        LOOP
  656.           (MULTIPLE-VALUE-BIND (DELTA-X DELTA-Y PRESSED-BUTTONS IGNORE)
  657.           (TV:MOUSE-INPUT)
  658.         (TELL SELF :MOVE-TO
  659.               (+ (CAR X-POSITION) (// DELTA-X 2))
  660.               (- (CAR Y-POSITION) (// DELTA-Y 2)))
  661.         (WHEN (= 0 PRESSED-BUTTONS) (GO LOOP))))))
  662.     (SETQ TV:MOUSE-X OLD-X TV:MOUSE-Y OLD-Y)
  663.     (TELL SELF :SET-XY (CAR X-POSITION) (CAR Y-POSITION))
  664.     (TELL *POINT-BLINKER* :SET-VISIBILITY :BLINK))
  665.       (FERROR "Follow-mouse can only be called when the graphics box is showing")))
  666.  
  667. (DEFMETHOD (TURTLE :USURP-MOUSE-WAITING-FOR-BUTTON-RAISE) (&AUX OLD-X OLD-Y)
  668.   (IF (GRAPHICS-BOX? ASSOC-GRAPHICS-BOX)
  669.       (UNWIND-PROTECT
  670.     (LET ((%MOUSE-USURPED T))
  671.       (TV:WITH-MOUSE-USURPED
  672.         (TAGBODY
  673.           (SETQ OLD-X TV:MOUSE-X OLD-Y TV:MOUSE-Y)
  674.           (SETQ TV:WHO-LINE-MOUSE-GRABBED-DOCUMENTATION "Sprite grabbed the mouse")
  675.           (TELL *POINT-BLINKER* :SET-VISIBILITY NIL)
  676.           (TELL TV:MOUSE-BLINKER :SET-VISIBILITY NIL)          
  677.        LOOP
  678.           (MULTIPLE-VALUE-BIND (DELTA-X DELTA-Y IGNORE RAISED-BUTTON IGNORE)
  679.           (TV:MOUSE-INPUT)
  680.         (TELL SELF :MOVE-TO
  681.               (+ (CAR X-POSITION) (// DELTA-X 2))
  682.               (- (CAR Y-POSITION) (// DELTA-Y 2)))
  683.         (WHEN (= 0 RAISED-BUTTON) (GO LOOP))))))
  684.     (SETQ TV:MOUSE-X OLD-X TV:MOUSE-Y OLD-Y)
  685.     (TELL SELF :SET-XY (CAR X-POSITION) (CAR Y-POSITION))
  686.     (TELL *POINT-BLINKER* :SET-VISIBILITY :BLINK))
  687.       (FERROR "Follow-mouse can only be called when the graphics box is showing")))
  688.  
  689. (DEFMETHOD (TURTLE :STAMP) ()
  690.   (TELL SELF :ERASE)
  691.   (LET ((PEN-MODE (GET-ALU-FROM-PEN (CAR PEN))))
  692.     (WHEN PEN-MODE
  693.       (TELL SELF :DRAW PEN-MODE))) 
  694.   (WHEN (TELL SELF :ABSOLUTE-SHOWN-P) (TELL SELF :DRAW)))
  695.  
  696. (DEFMETHOD (TURTLE :COPY-SELF) ()
  697.   (TELL SPRITE-BOX :COPY))
  698.